import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
import Graphics.Rendering.Cairo
import Data.IORef

-----------------------------------------------------------
-- type declarations
-----------------------------------------------------------
data Vector = Vector { xProjection::Double, yProjection::Double }
data Player = Player1 | Player2
data Cell = Occupied Player | Empty 
type Row = [Cell]
data Board = Board Vector [Row]
type Position = Vector
type Dimentions = Vector
type Column = Integer
data Intent = Intent Player Column

-----------------------------------------------------------
-- default settings and initialization functions
-----------------------------------------------------------
defaultBoardDimentions = Vector 7 7
userSpanceDimentions = Vector 100 100

borderThickness :: Double
borderThickness = 0.5 -- in user dimentions
stoneSizeToCell :: Double
stoneSizeToCell = 0.9
borderColor  = setSourceRGBA 0   0.3 0.3 1
player1color = setSourceRGBA 0.3 0.8 0.8 1
player2color = setSourceRGBA 0.8 0.3 0.3 1

-----------------------------------------------------------
-- Game functions
-----------------------------------------------------------
initBoard :: Vector -> Board
initBoard dim = Board dim (initBoardWorker dim (truncate $ yProjection dim))
  where
    initBoardWorker :: Vector -> Integer -> [Row]
    initBoardWorker dim 0 = []
    initBoardWorker dim h = (initRow $ truncate $ xProjection dim) : (initBoardWorker dim $ h-1)

    initRow :: Integer -> Row
    initRow 0 = []
    initRow l = Empty : (initRow $ l-1)

morthCell :: Position -> Cell -> Board -> Board
morthCell (Vector x y) new (Board dim board) = Board dim (posWorker dim (truncate $ yProjection dim) board)
  where
    posWorker :: Vector -> Integer -> [Row] -> [Row]
    posWorker dim 0 ys     = []
    posWorker dim h (y':ys) = (reverse $ rowWorker h (truncate $ xProjection dim) y') : (posWorker dim (h-1) ys)

    rowWorker :: Integer -> Integer -> Row -> Row
    rowWorker h 0 xs     = []
    rowWorker h l (x':xs)
      | h == (truncate y) && l == (truncate x) = new : (rowWorker h (l-1) xs)
      | otherwise                              = x'  : (rowWorker h (l-1) xs)

-- current player intended column
intent :: Board -> Intent
intent (Board dim board) = worker (head $ reverse board) 1
  where
    worker [] _ = error "Top row found empty."
    worker ((Occupied x):xs) n = Intent x n
    worker (x:xs) n = worker xs (n+1)

intentLeft :: Board -> Board
intentLeft board = intentChange board (-) 1

intentRight :: Board -> Board
intentRight (Board dim board) = intentChange (Board dim board) (+) (truncate $ xProjection dim)

intentChange :: Board -> (Column -> Column -> Column) -> Column -> Board
intentChange board op limit
    | intentColumn (intent board) == limit = board
    | otherwise                            =
      morthCell (Vector (fromIntegral $ op (intentColumn $ intent board) 1)  1) (Occupied $ intentPlayer $ intent board) (removeIntent board)

intentColumn :: Intent -> Column
intentColumn (Intent player column) = column

intentPlayer :: Intent -> Player
intentPlayer (Intent player column) = player

curPlayer :: Board -> Player
curPlayer board = intentPlayer $ intent board

changePlayer :: Board -> Board
changePlayer (Board dim board) = morthCell (defaultPlayerPos dim) (Occupied $ otherPlayer $ curPlayer $ b) (removeIntent b)
  where
    b = Board dim board

otherPlayer :: Player -> Player
otherPlayer Player1 = Player2
otherPlayer Player2 = Player1

-- BUG
removeIntent :: Board -> Board
removeIntent board = morthCell (Vector (fromIntegral $ intentColumn $ intent board) 1) Empty board

defaultPlayerPos :: Dimentions -> Position
defaultPlayerPos dim = Vector (fromIntegral $ truncate $ xProjection dim / 2 + 1) 1

newGame :: Dimentions -> Board
newGame dim = morthCell (defaultPlayerPos dim) (Occupied Player1) (initBoard dim)

-----------------------------------------------------------
-- render functions
-----------------------------------------------------------
cellDim :: Dimentions -> Dimentions
cellDim boardDim = Vector (f xProjection) (f yProjection)
  where
    f :: (Vector -> Double) -> Double
    f d = ((d userSpanceDimentions) - (d boardDim + 1) * borderThickness) / (d boardDim)

cellCoords :: Position -> Dimentions -> Position
cellCoords cell boardDim = Vector (f xProjection) (f yProjection)
  where
    f :: (Vector -> Double) -> Double
    f p = (p (cellDim boardDim) + borderThickness) * p cell - p (cellDim boardDim) / 2

drawPosition :: Position -> Player -> Board -> Render ()
drawPosition pos player (Board dim _) = do
    setLineWidth $ patternRadius player
    color player
    arc (xProjection posCoords) (yProjection posCoords) (0.5 * radius) 0 (2 * pi)
    stroke
    setLineWidth borderThickness
    borderColor
    arc (xProjection posCoords) (yProjection posCoords) radius 0 (2 * pi)
    stroke
  where
    color Player1 = player1color
    color Player2 = player2color
    patternRadius Player2 = radius
    patternRadius Player1 = radius - 4*borderThickness
    minCellDim = min (xProjection $ cellDim dim) (yProjection $ cellDim dim)
    radius = stoneSizeToCell * 0.5 * minCellDim
    posCoords = cellCoords pos dim

drawPositions :: Board -> Render ()
drawPositions (Board dim board) = posWorker board (truncate $ yProjection dim)
  where
    posWorker :: [Row] -> Integer -> Render ()
    posWorker _ 0 = return ()
    posWorker (row:rows) h = do
      rowWorker row h (truncate $ xProjection dim)
      posWorker rows (h-1)

    rowWorker :: [Cell] -> Integer -> Integer -> Render ()
    rowWorker _ _ 0 = return ()
    rowWorker (cell:row) h l = do
      drawPlayer cell (Vector (fromIntegral l) (fromIntegral h))
      rowWorker row h (l-1)

    drawPlayer :: Cell -> Position -> Render ()
    drawPlayer (Occupied player) pos = drawPosition pos player (Board dim board)
    drawPlayer _ _ = return ()

drawBoard :: Board -> Render ()
drawBoard (Board dim board) = do
  drawBorders dim
  drawPositions (Board dim board)
  stroke

drawBorders boardDim = do
    borderColor
    setLineWidth borderThickness
    drawBordersXworker (truncate $ xProjection boardDim)
    drawBordersYworker (truncate $ yProjection boardDim)
    stroke
  where
    pos :: (Vector -> Double) -> Integer -> Double
    pos d n = (fromIntegral n) * (d (cellDim boardDim) + borderThickness) + (borderThickness / 2)

    drawBordersXworker :: Integer -> Render ()
    drawBordersXworker 0 = do
      moveTo (borderThickness / 2) 0
      lineTo (borderThickness / 2) 100
    drawBordersXworker n = do
      drawBordersXworker (n-1)
      moveTo (pos xProjection n) 0
      lineTo (pos yProjection n) 100

    drawBordersYworker :: Integer -> Render ()
    drawBordersYworker 0 = do
      moveTo 0 (borderThickness / 2)
      lineTo 100 (borderThickness / 2)
    drawBordersYworker n = do
      drawBordersYworker (n-1)
      moveTo 0 (pos xProjection n)
      lineTo 100 (pos yProjection n)

render drawingArea gBoard event = do
  let scaleBy :: (Vector -> Double) -> Int -> Double
      scaleBy d v = (fromIntegral v) / (d userSpanceDimentions)
  win                 <- widgetGetDrawWindow drawingArea
  board               <- readIORef gBoard
  (winSizeX,winSizeY) <- widgetGetSize drawingArea
  renderWithDrawable win $ do
    scale (scaleBy xProjection winSizeX) (scaleBy yProjection winSizeY)
    drawBoard board
    return True

-----------------------------------------------------------
-- MAIN
-----------------------------------------------------------
main = do
  initGUI
  Just xml       <- xmlNew "fourinarow.glade"
  window         <- xmlGetWidget xml castToWindow "window1"
  boardDimDialog <- xmlGetWidget xml castToDialog "dialog1"
  menuNew        <- xmlGetWidget xml castToMenuItem "imagemenuitem1"
  menuQuit       <- xmlGetWidget xml castToMenuItem "imagemenuitem5"
  drawingArea    <- xmlGetWidget xml castToDrawingArea "drawingarea1"
  board          <- newIORef $ newGame defaultBoardDimentions
  onDestroy window mainQuit
  onExpose drawingArea (render drawingArea board)
  onActivateLeaf menuQuit mainQuit
  onActivateLeaf menuNew $ do
    response <- dialogRun boardDimDialog
--    bd <- readIORef boardDim
--    writeIORef board $ initBoard bd
    handleDialogNew response boardDimDialog board
  onKeyPress window (handleInput board)
  widgetShowAll window
  mainGUI

handleDialogNew ResponseNone _ _ = do
  putStrLn "None"
handleDialogNew ResponseDeleteEvent _ _ = do
  putStrLn "delete"
handleDialogNew (ResponseUser id) dialog board
  | id == 1 = do
                putStrLn "Ok"
  | id == 2 = do
                putStrLn "Cancel"
  | otherwise = error "ResponseUser error"
handleDialogNew _ _ _ = error "Response error"

handleInput gBoard (Key{ eventKeyName="Left" }) = do
  modifyIORef gBoard intentLeft
  board <- readIORef gBoard
  putStrLn $ show $ intentColumn $ intent board
  return True
handleInput gBoard (Key{ eventKeyName="Right" }) = do
  modifyIORef gBoard intentRight
  board <- readIORef gBoard
  putStrLn $ show $ intentColumn $ intent board
  return True
handleInput gBoard (Key{ eventKeyName="Down" }) = do
  putStrLn "Down"
  return True
handleInput gBoard _ = do
  return False

